perm filename STRUCT[DEN,LMM] blob
sn#070828 filedate 1973-11-08 generic text, type T, neo UTF8
(FILECREATED " 8-NOV-73 14:33:37" S-STRUCTURE
changes to: STRUCWITH2NODES
previous date: " 6-NOV-73 6:37:24")
(LISPXPRINT (QUOTE STRUCTUREVARS)
T)
(RPAQQ STRUCTUREVARS
((* I've tried to move all files that have to know what
structures look like into this file ; i've probably
failed. Help please; but please try to keep the file FNS
organized as well)
(FNS DAISY SINGLERING STRUCWITH2NODES COPYSTRUC)
(FNS PUTLOOPS PUTFVS PUTBIVS INSERTMARKERS)
(FNS PUTFVNODE PUTBIVNODE PUTBIVNODES PUTBIVEDGE
BIVALENTCHAIN)
(FNS CONNECT DISCONNECT)
(FNS FREEVALENCESIZE NODEVALENCE VALENCETYPE LISTBYVALENCE
COLLECTFV FINDCTE FIRSTOFNODES LASTOFNODES NODES)
(FNS RADICAL? CENTER? ATOMTYPE)
(RECORDS STRUCTURE RADICAL MAKECENTER MARKER-REC CTENTRY EDGE
STRUCFORM)))
(* I've tried to move all files that have to know what structures
look like into this file ; i've probably failed. Help please; but
please try to keep the file FNS organized as well)
(DEFINEQ
(DAISY
[LAMBDA (PART)
(PROG (STRUC NODENUMBER)
(SETQ STRUC (create STRUCTURE CTABLE←(LIST (create CTENTRY
NODENUM← 1))
UGRAPH←(CONS (QUOTE DAISY)
PART)
LASTNODE#← 1))
(FOR PAIR IN PART FOR I FROM 1 TO (CDR PAIR)
DO (PUTBIVNODE STRUC 1 (CAR PAIR)))
(RETURN (LIST STRUC])
(SINGLERING
[LAMBDA (N)
(create STRUCTURE CTABLE←[CONS (create CTENTRY NODENUM← 1 NBRS←(
LIST 2 N))
(NCONC1 (BIVALENTCHAIN 2
(SUB1 N))
(create CTENTRY NODENUM← N
NBRS←(LIST
1
(SUB1 N]
UGRAPH←(LIST (QUOTE SINGLERING)
N)
LASTNODE#← N])
(STRUCWITH2NODES
[LAMBDA (N AT1 AT2)
(PROG [(TEM (COND
((EQ N 2)
(SINGLERINGS 2))
(T (CATALOG (FOR I FROM 3 TO N XLIST
FIRST (LIST 2)
0]
(COND
([AND TEM (STRUCTURE? (SETQ TEM (CAR TEM]
(COND
((OR AT1 AT2)
(SETQ TEM (COPYSTRUC TEM))
(replace ATOMTYPE of
(fetch MARKERS of
(CAR (fetch CTABLE of TEM)))
with AT1)
(FOR I FROM 1 TO (IDIFFERENCE (VALENCE AT1)
N)
DO (NCONC1 (fetch NBRS of
(CAR (fetch CTABLE of TEM)))
(QUOTE FV)))
(FOR I FROM 1 TO (IDIFFERENCE (VALENCE AT2)
N)
DO (NCONC1 (fetch NBRS of
(CADR (fetch CTABLE of TEM)))
(QUOTE FV)))
(replace ATOMTYPE of
(fetch MARKERS of
(CADR (fetch CTABLE of TEM)))
with AT2)))
TEM)
(T (create STRUCTURE CTABLE←(LIST
(create CTENTRY NODENUM← 1 MARKERS←(create
MARKER-REC ATOMTYPE← AT1)
NBRS←(FOR I FROM 1 TO N XLIST
FIRST
(AND AT1 (FOR Z
FROM
(ADD1 N)
TO (VALENCE
AT1)
XLIST
(QUOTE FV)))
2))
(create CTENTRY NODENUM← 2 MARKERS←(create
MARKER-REC ATOMTYPE← AT2)
NBRS←(FOR I FROM 1 TO N XLIST
FIRST
(AND AT2 (FOR Z
FROM
(ADD1 N)
TO (VALENCE
AT2)
XLIST
(QUOTE FV)))
1)))
UGRAPH←(CONS (QUOTE MBONDS)
N)
LASTNODE#← 2])
(COPYSTRUC
[LAMBDA (STRUC)
(create STRUCTURE copying STRUC GROUP←(fetch GROUP of STRUC])
)
(DEFINEQ
(PUTLOOPS
[LAMBDA (STRUC LLCLLOOPS LLNODE)
(* LLCLLOOPS is a list of lists of loop compositions
-
LLLNODES is a list of lists of NODES -
The corresponding nodes get the corresponding loops)
[FOR LNODE IN LLNODE AS LCLLOOP IN LLCLLOOPS
DO (FOR NODE IN LNODE AS CLLOOP IN LCLLOOP
DO (FOR LOOPPAIR IN CLLOOP
DO (FOR I FROM 1 TO (CDR LOOPPAIR)
DO (FOR N IN NODE DO (PUTBIVNODE STRUC N
(CAR LOOPPAIR]
STRUC])
(PUTFVS
[LAMBDA (STRUC FVPART)
(* FVPART is a list of fv assignments, where a fv
assignment is a list, in order of number of fv's, of
lists of nodes)
[FOR LLNODE IN FVPART
DO (FOR LNODE IN LLNODE AS NFVS FROM 1
DO (FOR NODE IN LNODE DO (PUTFVNODE STRUC NODE NFVS]
STRUC])
(PUTBIVS
[LAMBDA (STRUC LNBIVS LLEDGE)
(* LLEDGE is a list of lists of edges -
LNBIVS is a list of number of bivalents)
(FOR LEDGE IN LLEDGE AS NBIVS IN LNBIVS
DO (FOR EDGE IN LEDGE DO (PUTBIVEDGE STRUC EDGE NBIVS)))
STRUC])
(INSERTMARKERS
[LAMBDA (STRUC CLL LLLNODE)
(FOR CL IN CLL AS LLNODE IN LLLNODE FOR PAIR IN CL AS LNODE
IN LLNODE FOR NODE
IN LNODE
DO (REPLACE ATOMTYPE OF (FETCH MARKERS OF (FINDCTE NODE STRUC))
WITH
(CAR PAIR)))
STRUC])
)
(DEFINEQ
(PUTFVNODE
[LAMBDA (STRUC NODE NUMFVS)
(SETQ NODE (FINDCTE NODE (fetch CTABLE of STRUC)))
(OR (fetch NBRS of NODE)
(HELP))
(NCONC (fetch NBRS of NODE)
(FOR I FROM 1 TO NUMFVS COLLECT (QUOTE FV)))
STRUC])
(PUTBIVNODE
[LAMBDA (STRUC NODENUM NUMBIVS)
(PUTBIVNODES STRUC NODENUM NODENUM NUMBIVS])
(PUTBIVNODES
[LAMBDA (STRUC NODE1 NODE2 NUMBIVS)
[OR (AND (STRUCTURE? STRUC)
(NUMBERP NODE2)
(NUMBERP NODE1)
(NUMBERP NUMBIVS))
(HELP (QUOTE (BAD ARG TO BUTBIVNODE]
[COND
((ZEROP NUMBIVS))
(T
(* STRUC is a STRUCTURE -
NODE1 is a node number -
NUMBIVS is the number of bivalents which are to be
attached, as a loop, to node NODE1)
(PROG ((LASTNUM (fetch LASTNODE# of STRUC))
(CTE1 (FINDCTE NODE1 STRUC))
(CTE2 (FINDCTE NODE2 STRUC)))
(NCONC1 CTE1 (ADD1 LASTNUM)) (* connect this node to
the chain beginning)
[NCONC (fetch CTABLE of STRUC)
(COND
[(EQ NUMBIVS 1)
(SETQ NUMBIVS LASTNUM)
(LIST (create CTENTRY NODENUM←(ADD1 LASTNUM)
NBRS←(LIST NODE1 NODE2]
(T (SETQ NUMBIVS (SUB1 (IPLUS LASTNUM NUMBIVS)))
(SETQ LASTNUM (ADD1 LASTNUM))
(CONS (create CTENTRY NODENUM← LASTNUM NBRS←(
LIST NODE1 (ADD1 LASTNUM)))
(NCONC1 (BIVALENTCHAIN (ADD1 LASTNUM)
NUMBIVS)
(create CTENTRY NODENUM←(ADD1
NUMBIVS)
NBRS←(LIST NODE2
NUMBIVS]
(* Create chain)
(NCONC1 CTE2 (SETQ LASTNUM (ADD1 NUMBIVS)))
(replace LASTNODE# of STRUC with LASTNUM]
STRUC])
(PUTBIVEDGE
[LAMBDA (STRUC EDGE NUMBIVS)
(COND
((ZEROP NUMBIVS)
STRUC)
(T (DISCONNECT (FINDCTE (CAR EDGE)
STRUC)
(FINDCTE (CDR EDGE)
STRUC))
(PUTBIVNODES STRUC (CAR EDGE)
(CDR EDGE)
NUMBIVS])
(BIVALENTCHAIN
[LAMBDA (START STOP)
(FOR I FROM START TO STOP COLLECT (create CTENTRY NODENUM← I NBRS←(
LIST (SUB1 I)
(ADD1 I])
)
(DEFINEQ
(CONNECT
[LAMBDA (X Y)
(PROG NIL
(REPLACE NBRS OF X WITH (CONS (FETCH NODENUM OF Y)
(FETCH NBRS OF X)))
(COND
((NOT (EQ X Y))
(REPLACE NBRS OF Y WITH (CONS (FETCH NODENUM OF X)
(FETCH NBRS OF Y])
(DISCONNECT
[LAMBDA (X Y)
(REPLACE NBRS OF X WITH (DELETE (FETCH NODENUM OF Y)
(FETCH NBRS OF X)))
(REPLACE NBRS OF Y WITH (DELETE (FETCH NODENUM OF X)
(FETCH NBRS OF Y])
)
(DEFINEQ
(FREEVALENCESIZE
[LAMBDA (S)
(COND
((STRUCTURE? S)
(FOR X IN (FETCH CTABLE OF S) FOR Y
IN (FETCH NBRS OF X)
WHEN (EQ Y (QUOTE FV))
SUM 1))
((AND (STRUCFORM? S)
(EQ (CAR (FETCH FORM OF S))
(QUOTE ATTACHFVS)))
(FOR FVL IN (CADR (FETCH FORM OF S)) FOR X IN FVL AS I
FROM 1
SUM (ITIMES I X)))
[(STRUCFORM? S)
(COND
[(EQ (CAR (FETCH FORM OF S))
(QUOTE RINGS))
(COMPUTEFV (CADR (FETCH FORM OF S))
(CADDR (FETCH FORM OF S]
(T (HELP]
(T (HELP "VALENCE" S])
(NODEVALENCE
[LAMBDA (NODE)
(COND
[(NULL NODE)
(ERROR (QUOTE (NULL NODE GIVEN TO NODEVALENCE]
((CTENTRY? NODE)
(LENGTH (FETCH NBRS OF NODE)))
(T (NODEVALENCE (FINDCTE (CAR NODE)
(CDR NODE])
(VALENCETYPE
[LAMBDA (S I)
(FOR NODE IN (FETCH CTABLE OF S) WHEN (EQ I (NODEVALENCE NODE))
XLIST
(FETCH NODENUM OF NODE])
(LISTBYVALENCE
[LAMBDA (S)
(PROG (M V)
(SETQ M (LENGTH (fetch CTABLE of S)))
(RETURN (FOR I FROM 2 WHILE (IGREATERP M 0)
COLLECT (SETQ V (VALENCETYPE S I))
(SETQ M (IDIFFERENCE M (LENGTH V)))
V])
(COLLECTFV
[LAMBDA (S)
(FOR CT IN (FETCH CTABLE OF S) FOR X IN (FETCH NBRS OF CT)
WHEN (EQ X (QUOTE FV))
XLIST
FIRST (AND (LISTP (FETCH ATOMTYPE OF (FETCH MARKERS OF CT)))
(FOR PR IN (CDR (FETCH ATOMTYPE OF
(FETCH MARKERS OF CT)))
WHEN (EQ (CAR PR)
(QUOTE FV))
FOR I
FROM 1
TO (CDR PR)
XLIST
(FETCH NODENUM OF CT)))
(FETCH NODENUM OF CT])
(FINDCTE
[LAMBDA (NODE STRUC)
(COND
((NUMBERP NODE)
(AND (STRUCTURE? STRUC)
(SETQ STRUC (fetch CTABLE of STRUC)))
(FOR L IN STRUC SUCHTHAT (EQ (fetch NODENUM of L)
NODE)))
((NUMBERP STRUC)
(FINDCTE STRUC NODE))
(T (ERROR (QUOTE (BAD ARGUMENTS TO FINDCTE))
STRUC])
(FIRSTOFNODES
[LAMBDA (X)
(fetch NODENUM of (CAR (fetch CTABLE of X])
(LASTOFNODES
[LAMBDA (X)
(fetch NODENUM of (CAR (LAST (fetch CTABLE of X])
(NODES
[LAMBDA (STRUC)
(MAPCAR (FETCH CTABLE OF STRUC)
(FUNCTION (LAMBDA (X)
(FETCH NODENUM OF X])
)
(DEFINEQ
(RADICAL?
[LAMBDA (X)
(AND X (CENTER? (fetch CENTER of X))
(EVERY (fetch ATTACHEDRADS of X)
(FUNCTION (LAMBDA (Y)
(NUMBERP (CDR Y))
(RADICAL? (CAR Y])
(CENTER?
[LAMBDA (X)
(COND
[(NLISTP X)
(OR (NULL X)
(GETP X (QUOTE VALENCE]
(T (AND (OR (NULL (fetch AFFLINK of X))
(NUMBERP (fetch AFFLINK of X)))
(STRUCTURE? (fetch RADSTRUC of X))
(EVERY (fetch CUFFLINKS of X)
(FUNCTION (LAMBDA (Y)
(EVERY Y (FUNCTION NUMBERP])
(ATOMTYPE
[LAMBDA (CTE)
(IF NLISTP CTE:MARKERS
THEN CTE:MARKERS
ELSE CTE:MARKERS:ATOMTYPE])
)
(TYPERECORD STRUCTURE (CTABLE UGRAPH LASTNODE# . GROUP) DEFAULT GROUP←
(LIST NIL))
(RECORD RADICAL (CENTER . ATTACHEDRADS))
(RECORD MAKECENTER (AFFLINK RADSTRUC . CUFFLINKS))
(RECORD MARKER-REC (ATOMTYPE . OTHERMARKERS))
(TYPERECORD CTENTRY (NODENUM MARKERS . NBRS) DEFAULT MARKERS← (CREATE
MARKER-REC))
(RECORD EDGE (NODE1 . NODE2))
(TYPERECORD STRUCFORM FORM)
STOP